home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / initobj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  19.2 KB  |  602 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "attr.h"
  16. #include "setprots.h"
  17. #include "gutilprots.h"
  18. #include "gmiscprots.h"
  19. #include "smiscprots.h"
  20. #include "gnodesprots.h"
  21. #include "initobjprots.h"
  22.  
  23. static Tuple proc_init_rec(Tuple, Node, Node);
  24. static Node initialization_proc(Symbol, Symbol, Tuple, Tuple);
  25. static Tuple build_comp_names(Node);
  26.  
  27. Node build_proc_init_ara(Symbol type_name)                /*;build_proc_init_ara*/
  28. {
  29.     /*
  30.      *  This is the   main procedure for  building default  initialization
  31.      *  procedures for array  types. Those  initialization  procedures are
  32.      *  built if  the type  given  contains  some subcomponent for which a
  33.      *  default initialization exists (at any level of nesting),  or if it
  34.      *  has determinants.
  35.      *  Note that scalar objects are not initialized at all, which implies
  36.      *  that they get whatever initial value is in that location in memory
  37.      *  This saves some time in object creation.
  38.      *
  39.      *  All init. procedures  have an 'out' parameter that  designates the
  40.      *  object being initialized (the space has already been allocated).
  41.      *
  42.      */
  43.  
  44.     int        side_effect;
  45.     Tuple    tup, formals, subscripts;
  46.     Symbol    c_type, ip, index_t, proc_name, index_sym;
  47.     Node    one_component, init_stmt, out_param, i_nodes, d_node, iter_node;
  48.     Fortup    ft1;
  49.     Node    iterator, index_node;
  50.  
  51. #ifdef TRACE
  52.     if (debug_flag) {
  53.         gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name);
  54.     }
  55. #endif
  56.  
  57.     side_effect = FALSE;     /* Let's hope... TBSL */
  58.  
  59.     tup = SIGNATURE(type_name);
  60.     c_type    = (Symbol) tup[2];
  61.     one_component = new_node(as_index);
  62.  
  63.     ip = INIT_PROC(base_type(c_type));
  64.     if (ip != (Symbol)0 ){
  65.         /* Use the initialization procedure for the component type */
  66.         init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE);
  67.     }
  68.     else if (is_task_type(c_type)) {
  69.         /* initialization is task creation. */
  70.         init_stmt =
  71.           new_assign_node(one_component, new_create_task_node(c_type));
  72.     }
  73.     else if (is_access_type(c_type)) {
  74.         /* default value is the null pointer. */
  75.         init_stmt = new_assign_node(one_component, new_null_node(c_type));
  76.     }
  77.     else {
  78.         init_stmt = (Node) 0;
  79.     }
  80.  
  81.     if (init_stmt != (Node)0) {
  82.         /* body of initialization procedure is a loop over the indices */
  83.         /* allocating each component. Generate loop variables and code */
  84.         /* for iteration, using the attributes of the type. */
  85.  
  86.         proc_name = new_unique_name("type_name+INIT");
  87.         out_param = new_param_node("param_type_name", proc_name,
  88.            type_name, na_out);
  89.         generate_object(N_UNQ(out_param));
  90.         formals               = tup_new1((char *) out_param);
  91.         subscripts            = tup_new(0);
  92.         FORTUP(index_t=(Symbol), index_types(type_name), ft1);
  93.             /*index          = index_t + 'INDEX';*/
  94.             index_sym          = new_unique_name("index_t+INDEX");
  95.             NATURE (index_sym) = na_obj;
  96.             TYPE_OF(index_sym) = index_t;
  97.             subscripts = tup_with(subscripts, (char *)new_name_node(index_sym));
  98.         ENDFORTUP(ft1);
  99.  
  100.         i_nodes         = new_node(as_list);
  101.         /* need tup_copy since subscripts used destructively below */
  102.         N_LIST(i_nodes) = tup_copy(subscripts);
  103.  
  104.         /* Build the tree for the one_component of the array. */
  105.         N_AST1(one_component) = out_param;
  106.         N_AST2(one_component) = i_nodes;
  107.         N_TYPE(one_component) = c_type;
  108.  
  109.         while (tup_size(subscripts)) {
  110.             /* Build loop from innermost index outwards. The iterations */
  111.             /* span the ranges of the array being initialized. */
  112.  
  113.             /* dimension spanned by this loop: */
  114.             d_node   = new_ivalue_node(int_const(tup_size(subscripts)), 
  115.               symbol_integer);
  116.             iterator = new_attribute_node(ATTR_O_RANGE,
  117.               new_name_node(N_UNQ(out_param)), d_node, type_name);
  118.  
  119.             index_node = (Node) tup_frome(subscripts);
  120.             iter_node        = new_node(as_for);
  121.             N_AST1(iter_node) = index_node;
  122.             N_AST2(iter_node) = iterator;
  123.  
  124.             init_stmt = new_loop_node(OPT_NODE, iter_node, 
  125.               tup_new1((char *)init_stmt));
  126.         }
  127.  
  128.         INIT_PROC(type_name) = proc_name;
  129.         return initialization_proc(proc_name, type_name,
  130.           formals, tup_new1((char *) init_stmt));
  131.     }
  132.     else {
  133.         return OPT_NODE;
  134.     }
  135.  
  136. }
  137.  
  138. Node build_proc_init_rec(Symbol type_name)                /*;build_proc_init_rec*/
  139. {
  140.     /*
  141.      *  This is the   main procedure for  building default  initialization
  142.      *  procedures for record  types. Those initialization  procedures are
  143.      *  built if  the type  given  contains  some subcomponent for which a
  144.      *  default initialization exists (at any level of nesting),  or if it
  145.      *  has determinants.
  146.      *  Note that scalar objects are not initialized at all, which implies
  147.      *  that they get whatever initial value is in that location in memory
  148.      *  This saves some time in object creation.
  149.      *
  150.      *  All init. procedures  have an 'out' parameter that  designates the
  151.      *  object begin initialized (the space has already been allocated).
  152.      *
  153.      */
  154.  
  155.     int        side_effect;
  156.     Node    invar_node; /* TBSL: is invar_node local??*/
  157.     Tuple    stmts, tup, nstmts, formals, invariant_fields;
  158.     Tuple    discr_list; /* is this local ?? TBSL */
  159.     Fortup    ft1;
  160.     Symbol    d, proc_name;
  161.     Node    param, var_node, out_param;
  162.  
  163.     Node    node, node1, node2, discr_value_node;
  164. #ifdef TRACE
  165.     if (debug_flag)
  166.         gen_trace_symbol("BUILD_PROC_INIT_REC", type_name);
  167. #endif
  168.  
  169.     side_effect = FALSE;     /* Let's hope... TBSL */
  170.  
  171.     /*
  172.      * The initialization procedure for records has the usual out param.,
  173.      * and one in parameter per discriminant. The CONSTRAINED flag is the
  174.      * first of the discriminants
  175.      */
  176.     proc_name = new_unique_name("Init_ type_name");
  177.     out_param = new_param_node("param_type_name", proc_name, type_name, na_out);
  178.     generate_object(proc_name);
  179.     generate_object(N_UNQ(out_param));
  180.     tup = SIGNATURE(type_name);
  181.     invar_node = (Node) tup[1];
  182.     var_node = (Node) tup[2];
  183.     discr_list = (Tuple) tup[3];
  184.     invariant_fields = build_comp_names(invar_node);
  185.  
  186.     stmts = tup_new(0);
  187.     if (tup_size(discr_list)) {
  188.         /* Generate formal parameters for each. The body of the procedure */
  189.         /* assigns them to the field of the object. */
  190.         /* Note: the 'constrained' field is part of the discriminants. */
  191.  
  192.         formals = tup_new(0);
  193.         FORTUP(d=(Symbol), discr_list, ft1);
  194.             param = new_param_node("param_type_name", proc_name, TYPE_OF(d),
  195.               na_in);
  196.             generate_object(N_UNQ(param));
  197.             formals = tup_with(formals, (char *) param );
  198.             stmts = tup_with(stmts,
  199.               (char *) new_assign_node(new_selector_node(out_param, d), param));
  200.             discr_value_node = new_selector_node (out_param, d);
  201.  
  202.             /* generate code in order to test if the value of discriminant is
  203.              * compatible with its subtype
  204.              */
  205.  
  206.             node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)),
  207.               OPT_NODE, TYPE_OF(d));
  208.             node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)),
  209.               OPT_NODE, TYPE_OF(d));
  210.             node = node_new (as_list);
  211.             make_if_node(node,
  212.               tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or,
  213.                  new_binop_node(symbol_lt, discr_value_node, node1,
  214.                  symbol_boolean),
  215.                 new_binop_node(symbol_gt, discr_value_node, node2,
  216.                  symbol_boolean),
  217.                 symbol_boolean),
  218.                 new_raise_node(symbol_constraint_error))), OPT_NODE);
  219.             stmts = tup_with(stmts, (char *) node);
  220.         ENDFORTUP(ft1);
  221.         formals = tup_with(formals, (char *) out_param );
  222.  
  223.         /* if there are default expressions for any other components, */
  224.         /* further initialization steps are needed. */
  225.         tup = proc_init_rec(invariant_fields, var_node, out_param);
  226.         /*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/
  227.         nstmts = tup_add(stmts, tup);
  228.         tup_free(stmts); 
  229.         tup_free(tup); 
  230.         stmts = nstmts;
  231.     }
  232.     else {
  233.         /* record without discriminants. There may still be default values */
  234.         /* for some components. */
  235.         formals = tup_new1((char *) out_param);
  236.         stmts   = proc_init_rec(invariant_fields, var_node, out_param);
  237.     }
  238.     if (tup_size(stmts)) {
  239.         INIT_PROC(type_name) = proc_name;
  240.         return initialization_proc(proc_name, type_name, formals, stmts);
  241.     }
  242.     else {
  243.         return OPT_NODE;
  244.     }
  245. }
  246.  
  247. static Tuple proc_init_rec(Tuple field_names, Node variant_node, Node out_param)
  248.                                                             /*;proc_init_rec*/
  249. {
  250.     /*
  251.      *  This is a subsidiary procedure to BUILD_PROC_INIT, which performs
  252.      *  the recursive part of construction of an initialization procedure
  253.      *  for a record type.
  254.      *
  255.      *  Input: field_names is a list of component unique names (excluding
  256.      *         discriminants. Variant node is the AST for the variant part
  257.      *         of a component list.
  258.      *      variant_node is the variant part of the record declaration
  259.      *      and has the same structure as a case statement.
  260.      *
  261.      *         out_param designates the object being initialized
  262.      *
  263.      *  Output: the statement list required to initialize this fragment of
  264.      *          the record, or [] if not default initialization is needed.
  265.      */
  266.  
  267.     Tuple    init_stmt, stmts;
  268.     Node        one_component, f_init, c_node, variant_list;
  269.     Symbol    f_type, f_name, ip;
  270.     Fortup    ft1;
  271.     int        empty_case;
  272.     Tuple    case_list, comp_case_list;
  273.     Node        choice_list, comp_list, disc_node;
  274.     Node        invariant_node, new_case, list_node, case_node;
  275.  
  276.     Tuple    tup, index_list;
  277.     int        nb_dim, i;
  278.     Node        d_node,  node, node1, node2, node3, node4, node5;
  279.     Symbol    one_index_type;
  280.  
  281.     /* process fixed part first. */
  282.     init_stmt = tup_new(0);
  283.     FORTUP(f_name=(Symbol), field_names, ft1);
  284.         one_component    = new_selector_node(out_param, f_name);
  285.         f_type           = TYPE_OF(f_name);
  286.         REC_WITH_TASKS |= (int) CONTAINS_TASK(f_type);
  287.  
  288.         f_init = (Node) default_expr(f_name);
  289.         if (f_init  != OPT_NODE) {
  290.             init_stmt = tup_with(init_stmt,
  291.               (char *) new_assign_node(one_component,
  292.                remove_discr_ref(f_init, out_param)));
  293.         }
  294.         else if ((ip = INIT_PROC(base_type(f_type)))!=(Symbol)0) {
  295.             init_stmt  = tup_with(init_stmt,
  296.               (char *) build_init_call(one_component, ip, f_type, out_param));
  297.         }
  298.         else if (is_task_type(f_type)) {
  299.             init_stmt  = tup_with(init_stmt, (char *)
  300.               new_assign_node(one_component, new_create_task_node(f_type)));
  301.         }
  302.         else if (is_access_type(f_type)) {
  303.             init_stmt  = tup_with(init_stmt, (char *)
  304.               new_assign_node(one_component, new_null_node(f_type)));
  305.         }
  306.  
  307.  
  308.         /* if we have an aray then we have to check if its bounds are
  309.          * compatible with the index subtypes (of the unconstrained array) 
  310.          * (This code was generated beforehand in type.c ("need_qual_r") but
  311.          * it was wrong : we have to test the bounds only if the field is
  312.          * present (case of variant record).
  313.          * The generation of the tests is easier here
  314.          */
  315.  
  316.         if (is_array_type (f_type)) {
  317.             tup = (Tuple) SIGNATURE(TYPE_OF(f_type));
  318.             index_list = tup_copy((Tuple) tup[1]);
  319.             nb_dim = tup_size(index_list);
  320.  
  321.             for (i = 1; i <= nb_dim; i++) {
  322.                 one_index_type = (Symbol) (tup_fromb (index_list));
  323.  
  324.                 d_node   = new_ivalue_node(int_const(i), symbol_integer);
  325.  
  326.                 node1 = new_attribute_node(ATTR_O_FIRST,
  327.                   one_component, d_node, one_index_type);
  328.  
  329.                 node2 = new_attribute_node(ATTR_O_LAST,
  330.                   one_component, d_node, one_index_type);
  331.  
  332.                 node3 = new_attribute_node(ATTR_T_FIRST,
  333.                   new_name_node(one_index_type), OPT_NODE, one_index_type);
  334.  
  335.                 node4 = new_attribute_node(ATTR_T_LAST,
  336.                   new_name_node(one_index_type), OPT_NODE, one_index_type);
  337.  
  338.                 node5 = new_binop_node(symbol_or,
  339.                   new_binop_node(symbol_lt, node1, node3, symbol_boolean),
  340.                   new_binop_node(symbol_gt, node2, node4, symbol_boolean),
  341.                   symbol_boolean);
  342.  
  343.                 node = node_new (as_list);
  344.                 make_if_node(node,
  345.                 tup_new1((char *) new_cond_stmts_node(
  346.                   new_binop_node(symbol_and,
  347.                   new_binop_node(symbol_le, node1, node2, symbol_boolean),
  348.                   node5, symbol_boolean),
  349.                   new_raise_node(symbol_constraint_error))), OPT_NODE);
  350.                 init_stmt  = tup_with(init_stmt, (char *) (node));
  351.             }
  352.         }
  353.     ENDFORTUP(ft1);
  354.  
  355.     /* then build case statement to parallel structure of variant part. */
  356.  
  357.     empty_case = TRUE;    /* assumption */
  358.     if (variant_node != OPT_NODE) {
  359.  
  360.         disc_node= N_AST1(variant_node);
  361.         variant_list = N_AST2(variant_node);
  362.  
  363.         case_list = tup_new(0);
  364.  
  365.         comp_case_list = N_LIST(variant_list);
  366.  
  367.         FORTUP(c_node=(Node), comp_case_list, ft1);
  368.             choice_list = N_AST1(c_node);
  369.             comp_list = N_AST2(c_node);
  370.             invariant_node = N_AST1(comp_list);
  371.             variant_node = N_AST2(comp_list);
  372.  
  373.             field_names = build_comp_names(invariant_node);
  374.             stmts = proc_init_rec(field_names, variant_node, out_param);
  375.  
  376.             /*empty_case and= stmts = [];*/
  377.             empty_case = empty_case ? (tup_size(stmts)==0) : FALSE;
  378.             new_case = (N_KIND(c_node) == as_others_choice) ?
  379.               new_node(as_others_choice) : new_node(as_variant_choices);
  380.             N_AST1(new_case) = copy_tree(choice_list);
  381.             N_AST2(new_case) = new_statements_node(stmts);
  382.             case_list = tup_with(case_list, (char *)  new_case );
  383.         ENDFORTUP(ft1);
  384.  
  385.         if (! empty_case) {
  386.             /* Build a case statement ruled by the value of the discriminant */
  387.             /* for this variant part. */
  388.  
  389.             list_node         = new_node(as_list);
  390.             N_LIST(list_node) = case_list;
  391.             case_node         = new_node(as_case);
  392.             N_AST1(case_node)  = new_selector_node(out_param, N_UNQ(disc_node));
  393.             N_AST2(case_node) = list_node;
  394.             init_stmt    = tup_with(init_stmt, (char *) case_node );
  395.         }
  396.     }
  397.     return init_stmt;
  398. }
  399.  
  400. int is_discr_ref(Node expr_node)                            /*;is_discr_ref*/
  401. {
  402.     int     n, i, nk;
  403.     Node    node;
  404.     Tuple    tup;
  405.  
  406.     if (N_KIND(expr_node) == as_discr_ref)
  407.         return TRUE;
  408.  
  409.     nk = N_KIND(expr_node);
  410.     node = N_AST1(expr_node);
  411.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  412.     node = N_AST2_DEFINED(nk) ? N_AST2(expr_node) : (Node) 0;
  413.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  414.     node = N_AST3_DEFINED(nk) ? N_AST3(expr_node) : (Node) 0;
  415.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  416.     node = N_AST4_DEFINED(nk) ? N_AST4(expr_node) : (Node) 0;
  417.     if (node != (Node)0 && is_discr_ref(node)) return TRUE;
  418.     tup = N_LIST_DEFINED(nk) ? N_LIST(expr_node) : (Tuple) 0;
  419.     if (tup==(Tuple)0) return FALSE;
  420.     n = tup_size(tup);
  421.     for (i = 1; i <= n; i++)
  422.         if (is_discr_ref((Node) tup[i])) return TRUE;
  423.     return FALSE;
  424. }
  425.  
  426. Node remove_discr_ref(Node expr_node, Node object)        /*;remove_discr_ref*/
  427. {
  428.     /* Within the record definition, a discriminant reference can be replaced
  429.      * by a selected component for the instance of the record being built.
  430.      */
  431.  
  432.     Node        e;
  433.     int        i, nk;
  434.     Tuple    tup;
  435.  
  436.     if (N_KIND(expr_node) == as_discr_ref)
  437.         return new_selector_node(object, N_UNQ(expr_node));
  438.     else if (N_KIND(expr_node) == as_opt)
  439.         return OPT_NODE;
  440.     else {
  441.         e = copy_node(expr_node);
  442.         nk = N_KIND(e);
  443.         if (N_AST1_DEFINED(nk) && N_AST1(e)!=(Node)0)
  444.             N_AST1(e) = remove_discr_ref(N_AST1(e), object);
  445.         if (N_AST2_DEFINED(nk) && N_AST2(e)!=(Node)0)
  446.             N_AST2(e) = remove_discr_ref(N_AST2(e), object);
  447.         if (N_AST3_DEFINED(nk) && N_AST3(e)!=(Node)0)
  448.             N_AST3(e) = remove_discr_ref(N_AST3(e), object);
  449.         if (N_AST4_DEFINED(nk) && N_AST4(e)!=(Node)0)
  450.             N_AST4(e) = remove_discr_ref(N_AST4(e), object);
  451.     }
  452.     /*N_LIST(e) = [remove_discr_ref(n, object): n in N_LIST(e)];*/
  453.     if (N_LIST_DEFINED(nk) && N_LIST(e)!=(Tuple)0) {
  454.         tup = N_LIST(e);
  455.         for (i = 1; i <= tup_size(tup); i++)
  456.             tup[i] = (char *) remove_discr_ref((Node) tup[i], object);
  457.     }
  458.     return e;
  459. }
  460.  
  461. static Node initialization_proc(Symbol proc_name, Symbol type_name,
  462.   Tuple formals, Tuple stmts)                            /*;initialization_proc*/
  463. {
  464.     /* Build procedure with given formals and statement list. */
  465.  
  466.     Node    proc_node;
  467.  
  468.     int        i, n;
  469.     Tuple    tup;
  470.     NATURE   (proc_name)  = na_procedure;
  471.     n = tup_size(formals);
  472.     tup = tup_new(n);
  473.  
  474.     for (i = 1; i <= n; i++)
  475.         tup[i] = (char *) N_UNQ((Node)formals[i]);
  476.     SIGNATURE(proc_name)  = tup;
  477.     generate_object(proc_name);
  478.  
  479.     /* 
  480.      * Create as_subprogram_tr node with statements node as N_AST1 
  481.      * instead of N_AST3 as it is with as_subprogram.
  482.      */
  483.     proc_node         = new_node(as_subprogram_tr);
  484.     N_UNQ(proc_node) = proc_name;
  485.     N_AST1(proc_node)  = new_statements_node(stmts);
  486.     N_AST2(proc_node)  = OPT_NODE;
  487.     N_AST4(proc_node)  = OPT_NODE;
  488.  
  489.     return proc_node;
  490. }
  491.  
  492. Node build_init_call(Node one_component, Symbol proc_name, Symbol c_type,
  493.   Node object)                                                /*;build_init_call*/
  494. {
  495.     /*
  496.      * Construct statement to initialize an object component for which
  497.      * an initialization procedure exists. The statement is a call to that
  498.      * procedure.
  499.      * c_type is the (composite) type of the component.
  500.      * If this is a record type whose discriminants have default values,
  501.      * use these defaults as parameters of the initialization procedure.
  502.      *
  503.      * If it is a subtype, use  the discriminant  values  elaborated for
  504.      * the subtype template.
  505.      *
  506.      * In the case of record component that is a record subtype, the const-
  507.      * raint may be given by a discriminant of the outer record. Such const-
  508.      * raints can only be evaluated when the outer object itself is being
  509.      * elaborated. In  that case  the  value of discriminant is rewritten as
  510.      * a selected  component of the enclosing object.
  511.      *
  512.      * The constrained bit is treated like other discriminants. Its value is
  513.      * FALSE for a record type, TRUE for a record subtype.
  514.      *
  515.      * If this is an array type, the procedure has one_component as its
  516.      * single actual.
  517.      */
  518.  
  519.     Tuple    disc_vals, tup, discr_map, arg_list;
  520.     Fortup    ft1;
  521.     Symbol    d;
  522.     Node    node, p_node, args_node, d_val, d_val_new;
  523.     int        i, n;
  524.  
  525. #ifdef TRACE
  526.     if (debug_flag)
  527.         gen_trace_symbol("BUILD_INIT_CALL", proc_name);
  528. #endif
  529.  
  530.     if (is_record_type(c_type)) {
  531.         if (is_record_subtype(c_type)) {
  532.             /* examine constraint of subtype. */
  533.             disc_vals = tup_new(0);
  534.             tup = SIGNATURE(c_type);
  535.             discr_map = (Tuple) tup[2];
  536.  
  537.             FORTUP(d=(Symbol), discriminant_list_get(c_type), ft1);
  538.                 d_val = discr_map_get(discr_map, d);
  539.                 if (is_discr_ref(d_val) ) {
  540.                     /* depends on determinant of outer object */
  541.                     d_val_new = remove_discr_ref(d_val, object);
  542.                 }
  543.                 else if (is_ivalue(d_val) ) {
  544.                     /* useless to retrieve from subtype here */
  545.                     d_val_new = d_val;
  546.                 }
  547.                 else {
  548.                     /* elaborated: retrieve from subtype. */
  549.                     d_val_new = new_discr_ref_node(d, c_type);
  550.                 }
  551.                 disc_vals = tup_with(disc_vals, (char *) d_val_new);
  552.             ENDFORTUP(ft1);
  553.         }
  554.         else {
  555.             /* Use default values to initialize discriminants. */
  556.             tup = discriminant_list_get(c_type);
  557.             n = tup_size(tup);
  558.             disc_vals = tup_new(n);
  559.             for (i = 1; i <= n; i++)
  560.                 disc_vals[i] = (char *) default_expr((Symbol) tup[i]);
  561.         }
  562.         arg_list = disc_vals;/* last use of disc_vals so no need to copy*/
  563.         arg_list = tup_with(arg_list, (char *) one_component);
  564.     }
  565.     else {
  566.         arg_list = tup_new1((char *) one_component);
  567.     }
  568.  
  569.     /* Build call to initialization procedure. */
  570.     node              = new_node(as_init_call);
  571.     p_node            = new_name_node(proc_name);
  572.     args_node         = new_node(as_list);
  573.     N_LIST(args_node) = arg_list;
  574.     N_AST1(node)       = p_node;
  575.     N_AST2(node)       = args_node;
  576.     N_SIDE(node)      = FALSE;
  577.     return node;
  578. }
  579.  
  580. static Tuple build_comp_names(Node invariant_node)        /*;build_comp_names*/
  581. {
  582.     /* Collect names of record components in the invariant part of the
  583.      * record. Skip nodes generated for internal anonymous subtypes.
  584.      */
  585.  
  586.     Tuple    all_component_names;
  587.     Node    node, id_list_node, id_node;
  588.     Fortup    ft1, ft2;
  589.  
  590.     all_component_names = tup_new(0);
  591.     FORTUP(node=(Node), N_LIST(invariant_node), ft1);
  592.         if(N_KIND(node) ==as_subtype_decl || N_KIND(node)==as_deleted)
  593.             continue;
  594.         id_list_node= N_AST1(node);
  595.         FORTUP(id_node=(Node), N_LIST(id_list_node), ft2);
  596.             all_component_names  = tup_with(all_component_names,
  597.               (char *) N_UNQ(id_node));
  598.         ENDFORTUP(ft2);
  599.     ENDFORTUP(ft1);
  600.     return all_component_names;
  601. }
  602.